home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / TR.4TH < prev    next >
Text File  |  1994-10-30  |  12KB  |  403 lines
  1. \ TR PROGRAM
  2. \ TRANSLATES SOURCE FILE INTO DESTINATION FILE.
  3. \ WORKS LIKE UNIX tr WITH FOLLOWING EXCEPTIONS:
  4. \ 1. -A OPTION NEEDED FOR ASCII FILES.
  5. \ 2. HANDLES NULL CHARACTERS!
  6.  
  7. \ This program Copyright (C) 1985 by Thomas Almy.
  8. \ Permission is granted to registered users of ForthCMP to sell or distribute
  9. \ computer programs incorporating the compiled contents of this file.
  10.  
  11.  
  12. 0 [IF]
  13.  
  14. ( note -- program has been modified since writing this paper, and
  15.   this paper benchmarks the original CP/M version of the compiler)
  16.  
  17.                               TRANSLATE PROGRAM
  18.                                  by Tom Almy
  19.                                  August 1985
  20.  
  21. PROGRAM DESCRIPTION     
  22.  
  23.      This program was designed to mimic the functionality of the "tr"
  24. program provided on UNIX (tm Bell Labs) systems.  While written to be
  25. compiled with the author's ForthCMP Forth Compiler, it can be
  26. utilized on any 83 Standard system by providing an appropriate file
  27. system interface.
  28.  
  29.      TR is used to make one or more single character substitutions in
  30. a file.  ForthCMP's FILTER file interface allows specifying an input
  31. file and an optional output file (if no output file is specified,
  32. output goes to the display).  The file name(s) are followed by an
  33. optional option specification and one or two character specifying
  34. strings. 
  35.  
  36.      Characters in the strings may be any character except "\"
  37. (backslash) or "-" (hyphen).  Any of the 256 possible character codes
  38. can be specified by backslash followed by one, two, or three octal
  39. digits.  Backslash followed by a lower case character becomes an
  40. upper-case character (done to allow putting the string on a CP/M
  41. command line).  Backslash followed by any other character is that
  42. character, so "-" can be represented as "\-" and "\" can be
  43. represented as "\\".  A range of characters can be represented by the
  44. first character followed by a hyphen followed by the last character.
  45.  
  46.      If no options are specified, a translation occurs in which each
  47. character which is in the first specification string is replaced with
  48. the character in the same position in the second specification
  49. string.  If the second string is shorter than the first then the
  50. string is extended by appending copies of its last character.
  51.  
  52.      The option specifcation can contain any or all of the following
  53. characters:
  54.  
  55. A ASCII mode: On input CR is deleted (leaving just LF of CR-LF pairs)
  56.      and on output LF is replaced with CR-LF pairs.  This allows 
  57.      translating to or from CR-LF pairs.  Additionally, Control-Z denotes
  58.      end of file.
  59.  
  60. C Complement first string: The first string is replaced with a new
  61.      string consisting of the characters in the range 0 through 255
  62.      not in the first string.  This string is sorted.
  63.  
  64. D Delete instead of translate: No translation takes place; 
  65.      instead any characters in the first specification string are deleted.
  66.  
  67. S Squeeze output: Sequential occurrences in the character stream
  68.      (after translation/deletion) of two or more identical
  69.      characters in the second specification string are squeezed to a
  70.      single occurrence.
  71.  
  72. Example commands:
  73.  
  74. Options   String1        String2        Function
  75.           a-z            A-Z            Upcase file
  76.           a-zA-Z         A-Za-z         Swap case file
  77. AS        \12            \12            Delete blank lines
  78. ACS       !-~            \12            Put all words on separate lines
  79. AS        \40            \12            Put all words on separate lines
  80. ACDS      A-Za-z\12\40                  Delete all non alphabetics, except
  81.                                         spaces and newlines.
  82.           \200-\377      \0-\177        Clear parity bits.
  83.  
  84. PERFORMANCE
  85.  
  86.      I compared the performance of the Forth program, using the
  87. ForthCMP compiler, with that of C, using the MANX (AZTEC) compiler.
  88. The system used was a LOBO MAX-80, which has a 5-Mhz Z-80 processor,
  89. 1.2 MByte 8" floppy drives, and runs CP/M+.
  90.  
  91.  
  92. Characteristic                          Forth          C
  93.  
  94. Source file lines (not blank)           163            139
  95.  
  96. Compilation time    Compile Step        44             44   seconds
  97.                     Assemble Step       none           32
  98.                     Link Step           none           38         
  99.                     TOTAL               44             114
  100.  
  101. COM file size                           3584           9984 bytes
  102.  
  103. Test case execution time                21             138  seconds
  104.  
  105.      The test case involved upcasing a 14k byte file.  The PIP
  106. program (which is written in assembly language) took 16 seconds.
  107.  
  108.      The ForthCMP compiler compiles and links in a single step.  5
  109. seconds was spent producing a load map (not done in the C example),
  110. so the ForthCMP compilation time could really be considered to be 39
  111. seconds.  
  112.  
  113.  
  114.  
  115. READING THE LISTING
  116.  
  117.      First, ignore the INCLUDE, ROMABLE, and IN/OUT commands, as they
  118. are directives for the compiler.  The definition of CARRAY is "CREATE
  119. ALLOT DOES> +".  The definition of C<- is "SWAP C!". The non-standard
  120. words ?DO " <= >= ON OFF ASCII CONTROL SKIP and SCAN and Eaker' case
  121. statement (CASE OF ENDOF ENDCASE) have their usual definitions.
  122.  
  123.      The file interface redefines KEY and EXPECT to read from the
  124. input file.  KEY returns -1 on end of file; otherwise it returns the
  125. next character as an integer in the range 0 through 255.  Because the
  126. new EXPECT does not echo and has no editing, OLD- EXPECT (which is
  127. system dependent) had to be provided.  Output (EMIT and words which
  128. call it) is rewritten to send output to the output file when FILTER
  129. is executed, or to the display when CONSOLE is executed.
  130.  
  131.      SETFILES is used to initialize the input and output files, and
  132. returns TRUE if successful.  The double variable OPTIONSTRING is set
  133. to contain a pointer to and length of the command tail (that part
  134. excluding the file specifications).  ENDFILES does any necessary file
  135. closing.
  136.  
  137.  
  138.  
  139. [THEN]
  140.  
  141.  
  142.  
  143. \ Modified for new filter August, 1986
  144. \ Modified for newest DOS interface 12/91
  145. 100 MSDOS
  146. HEX 4000 DECIMAL CONSTANT BUFSIZ
  147. INCLUDE DOS1
  148.  
  149.  
  150. 256 CARRAY TRTABLE  \ translation table 
  151. 256 CARRAY SQTABLE  \ squeeze duplicates table 
  152. CREATE  INLIST  512 ALLOT  \ instring values 
  153. CREATE  OUTLIST 512 ALLOT  \ outstring values 
  154. VARIABLE DEL-FLAG   \ deletion flag specified 
  155. VARIABLE COM-FLAG   \ reverse sense flag specified 
  156. VARIABLE SQU-FLAG   \ squeeze output string flag 
  157. VARIABLE ASC-FLAG   \ ascii-mode --> CR dropped on input, added
  158.                     \ before LF's on output , CONTROL-Z terminates file 
  159. VARIABLE ^LIST
  160. VARIABLE LASTCHAR
  161.  
  162. CTRL M CONSTANT ACR    \ Carriage Return
  163. CTRL J CONSTANT ALF    \ Line Feed
  164.  
  165.  
  166. \ OUTPUT FILE HANDLING ( basically filter.4th )
  167.  
  168. VARIABLE outhandle  stderr outhandle !
  169. VARIABLE outbuffer
  170. VARIABLE outbufptr
  171. VARIABLE outbufend
  172.  
  173. 0 0 IN/OUT 
  174. : flushout   outbuffer @ outbufptr @ <> IF
  175.     outhandle @ outbuffer @  outbufptr @ outbuffer @ - DUP >R write
  176.     outbuffer @ outbufptr ! R> <> IF  stderr outhandle !
  177.         ." DISK FULL " flushout 4 RETURN THEN 
  178.     THEN ;
  179.  
  180. : EMIT  outbufptr @ DUP outbuffer @ BUFSIZ + = IF flushout
  181.    DROP outbuffer @ THEN C! 1 outbufptr +! ;
  182.  
  183. 0 0 IN/OUT 
  184. : CONSOLE flushout stderr outhandle ! ;
  185.  
  186. 0 0 IN/OUT 
  187. : FILTER  flushout stdout outhandle ! ;
  188.  
  189. 0 0 IN/OUT : BYE flushout  bye ;
  190.  
  191. 0 0 IN/OUT : ABORT flushout 4 RETURN ;
  192.  
  193. \ INPUT FILE PROCESSING
  194. VARIABLE inbuffer  ( pointer to allocated buffer )
  195. VARIABLE inbufptr  
  196. VARIABLE inbufend
  197.  
  198. 0 0 IN/OUT
  199. : SETBUFS  ( must execute before any I/O to allocate buffers )
  200.   129 128 C@ >BUFFER
  201.   HERE inbuffer !
  202.   BUFSIZ ALLOT
  203.   HERE DUP outbuffer ! outbufptr !
  204.   BUFSIZ ALLOT
  205.   ; 
  206.  
  207.  
  208.  
  209. \ This version of KEY returns -1 on end of file!
  210. : KEY  inbufptr @ inbufend @ = IF ( fetch block )
  211.     stdin inbuffer @ BUFSIZ read ?DUP 0= IF ( EOF/ERROR ) -1  EXIT THEN
  212.     inbuffer @ + inbufend !
  213.     inbuffer @ inbufptr ! THEN
  214.     inbufptr @ C@  1 inbufptr +!  ;
  215.  
  216.  
  217. \ Commentary
  218. 0 0 IN/OUT
  219. : HELLO
  220.   ." TRANSLATE PROGRAM" CR
  221.   ." Copyright (C) 1985 by Thomas Almy." CR ;
  222.  
  223. 0 0 IN/OUT
  224. : USAGE
  225.     CONSOLE 
  226.     CR ." [-[A][C][D][S]] str1 [str2]"
  227.     CR  ." Options are Ascii Complement-str1 Delete Squeeze"
  228.     CR  ." strings may have \octal or range specifications."
  229.     ABORT
  230. ;
  231.  
  232. \ List Accessing
  233. 1 0 IN/OUT
  234. : ISLIST ( list -- ) ^LIST ! ;
  235.  
  236. 1 0 IN/OUT
  237. : !LIST ( char -- ) ^LIST @ !  2 ^LIST +! ;
  238.  
  239. 0 1 IN/OUT
  240. : @LIST ( -- char ) ^LIST @ @  2 ^LIST +! ;
  241.  
  242. \ Miscellaneous Subroutines
  243. 1 1 IN/OUT
  244. : UPCASE  ( char -- char )
  245.    DUP [CHAR] a >= IF DUP [CHAR] z <= IF BL - THEN THEN ;
  246.  
  247. PRIMITIVE
  248. : NEXT-CHAR ( addr len -- addr+1 len-1 char, or zero if end )
  249.    DUP IF 1- SWAP COUNT ROT SWAP ELSE FALSE THEN ;
  250.  
  251. PRIMITIVE
  252. : OCTAL? ( addr len -- addr len boolean )
  253.    OVER C@ DUP [CHAR] 0 >= SWAP [CHAR] 7 <= AND ;
  254.  
  255. : ?BACKSLASH ( addr len char -- addr' len' value )
  256.    DUP [CHAR] \ = IF DROP
  257.    OCTAL? IF NEXT-CHAR [CHAR] 0 - >R
  258.         OCTAL? IF NEXT-CHAR [CHAR] 0 - R> 8 * + >R
  259.           OCTAL? IF NEXT-CHAR [CHAR] 0 - R> 8 * + >R
  260.         THEN THEN R>
  261.     ELSE
  262.         NEXT-CHAR  
  263.    THEN THEN ;
  264.  
  265. : FILL-LIST ( string length list -- )
  266.   ISLIST
  267.   BEGIN  NEXT-CHAR ?DUP  WHILE
  268.     DUP [CHAR] - = IF DROP NEXT-CHAR ?BACKSLASH 1+
  269.         ^LIST @ CELL- @ 1+  DO I !LIST LOOP  ELSE
  270.     ?BACKSLASH !LIST  THEN  REPEAT
  271.   -1 !LIST ( delimit list )
  272.   2DROP ;
  273.  
  274.  
  275. \ Handle option string
  276. 0 0 IN/OUT
  277. : DO-OPTION-STRING
  278.     HERE COUNT SWAP 1+ SWAP 1 ?DO
  279.         COUNT UPCASE CASE
  280.             [CHAR] A OF  ASC-FLAG ON ENDOF
  281.             [CHAR] D OF  DEL-FLAG ON ENDOF
  282.             [CHAR] C OF  COM-FLAG ON ENDOF
  283.             [CHAR] S OF  SQU-FLAG ON ENDOF
  284.             ." UNKNOWN OPTION -- " EMIT USAGE ENDCASE
  285.         LOOP 
  286.     DROP
  287.     BL WORD DROP  ( scan next word )
  288.     ;
  289.  
  290. 0 0 IN/OUT
  291. : SET-OPTIONS
  292.     ASC-FLAG OFF
  293.     DEL-FLAG OFF
  294.     COM-FLAG OFF
  295.     SQU-FLAG OFF
  296.     BL WORD COUNT 0> SWAP C@ [CHAR] - = AND IF ( an option string )
  297.         DO-OPTION-STRING  
  298.     THEN
  299.     ;
  300.  
  301.  
  302. \ Various Table handling routines
  303. 1 0 IN/OUT 
  304. : SET-SQUTABLE    ( hostlist -- )  ISLIST
  305.   ['] SQTABLE >BODY 256 0 FILL
  306.    BEGIN  @LIST DUP 0< 0= WHILE
  307.             SQTABLE TRUE C<- ( set flag in byte )
  308.    REPEAT DROP ;
  309.  
  310. 0 0 IN/OUT 
  311. : COMPLEMENT-LIST ( complements INLIST )
  312.   INLIST  SET-SQUTABLE  INLIST ISLIST
  313.   256 0 DO I SQTABLE C@ 0= IF I !LIST THEN LOOP
  314.   -1 !LIST  ;
  315.  
  316. 0 0 IN/OUT
  317. : FILL-TRTABLE   ( TRTABLE gets filled from INLIST )
  318.   ['] TRTABLE >BODY 256 0 FILL
  319.      INLIST ISLIST BEGIN  @LIST DUP 0< 0= WHILE
  320.            TRTABLE TRUE C<-  ( set flag in byte )
  321.       REPEAT  DROP ;
  322.  
  323. 0 0 IN/OUT
  324. : SET-TRTABLE  ( TRTABLE is translation table from INLIST to OUTLIST )
  325.    256 0 DO I DUP TRTABLE C! LOOP   INLIST ISLIST
  326.    OUTLIST BEGIN  ^LIST @ @ 0< 0= WHILE
  327.       DUP @ 0< IF DUP CELL- @ ELSE DUP @ SWAP CELL+ SWAP THEN
  328.       @LIST TRTABLE C! REPEAT
  329.    DROP ;
  330.  
  331. \ Information from user?
  332. 0 0 IN/OUT
  333. : GET-RANGES
  334.     HERE COUNT INLIST FILL-LIST
  335.     COM-FLAG @ IF 
  336.         COMPLEMENT-LIST 
  337.     THEN
  338.     
  339.     BL WORD COUNT OUTLIST FILL-LIST
  340.     SQU-FLAG @ IF 
  341.         OUTLIST SET-SQUTABLE 
  342.     THEN
  343.     DEL-FLAG @ IF 
  344.         FILL-TRTABLE 
  345.     ELSE 
  346.         SET-TRTABLE 
  347.     THEN
  348. ;
  349.  
  350. \ Translate functions
  351. PRIMITIVE
  352. : NOT-DELETED? ( key -- key TRUE OR FALSE )
  353.     DUP TRTABLE C@  IF DROP FALSE  ELSE TRUE THEN ;
  354.  
  355. 1 0 IN/OUT
  356. : SEND-IT SQU-FLAG @ IF
  357.            DUP SQTABLE C@ IF
  358.              DUP LASTCHAR @ = IF  ( a duplicate! )
  359.                 DROP EXIT THEN THEN
  360.            DUP LASTCHAR ! THEN
  361.     DUP ALF = IF
  362.     ASC-FLAG @ IF
  363.         ACR EMIT THEN THEN
  364.    EMIT ;
  365.  
  366. : NEW-KEY? ( -- key TRUE OR FALSE )
  367.     ASC-FLAG @ IF 
  368.           BEGIN KEY DUP ACR = WHILE DROP REPEAT
  369.         DUP 0< OVER [CTRL] Z = OR   
  370.     ELSE
  371.         KEY DUP 0<  
  372.     THEN  
  373.     IF DROP FALSE ELSE TRUE THEN ;
  374.  
  375. 0 0 IN/OUT
  376. : TRANSLATE  
  377.     LASTCHAR ON
  378.     BEGIN 
  379.         NEW-KEY? 
  380.     WHILE
  381.         DEL-FLAG @ IF 
  382.             NOT-DELETED? IF SEND-IT THEN
  383.         ELSE  
  384.             TRTABLE C@  SEND-IT 
  385.         THEN
  386.     REPEAT
  387.    ;
  388.  
  389. \ TOP LEVEL
  390. : MAIN   
  391.     SETBUFS
  392.     HELLO
  393.     FILTER
  394.     SET-OPTIONS
  395.     GET-RANGES
  396.     TRANSLATE
  397.     BYE
  398. ;
  399.  
  400. INCLUDE DOS2
  401. INCLUDE FORTHLIB
  402. END
  403.